DATA 622 Final Project

Setup

library(skimr)
library(tidyverse)
library(readr)
library(dplyr)

Data

mnist_raw <- read_csv("https://pjreddie.com/media/files/mnist_train.csv", col_names = FALSE)

# Reduce the dataset down from 60,000 observations
mnist_subset <- mnist_raw %>%  head(5000)
# Relabel X1 and add instance number
mnist_subset <- mnist_subset  %>%  rename(label = X1) %>%  mutate(instance = row_number())
# Gather columns into x, y values
mnist_subset 

X <- mnist_subset %>% select(contains('X'))
y <- mnist_subset$label 

pixels_gathered <- mnist_subset %>%  gather(pixel, value, -label, -instance) %>%  tidyr::extract(pixel, "pixel", "(\\d+)", convert = TRUE) %>%  mutate(pixel = pixel - 2, x = pixel %% 28, y = 28 - pixel %/% 28)
pixels_gathered

Example instances. Replace by 10x10 tile plot shoring 10 instance of 1 number for every row

theme_set(theme_light())
pixels_gathered %>%  filter(instance <= 12) %>%  ggplot(aes(x, y, fill = value)) +  geom_tile() +  facet_wrap(~ instance + label) + scale_fill_gradient(low = "white", high = "black")

Data Exploration

Fairly even distribution. Can also try random sampling instead of head(10000) at the top.

ggplot(mnist_subset, aes(label)) + geom_bar()

The majority of points are either 0 (white) or 255 (black). Most values are not useful. Dimensionality reduction

ggplot(pixels_gathered, aes(value)) +  geom_histogram(bins=256)

pixel_summary <- pixels_gathered %>%  group_by(x, y, label) %>%  summarize(mean_value = mean(value)) %>%  ungroup()

## `summarise()` regrouping output by 'x', 'y' (override with `.groups` argument)

Average numbers representations. Gives a good idea of variability

pixel_summary %>%  ggplot(aes(x, y, fill = mean_value)) +  geom_tile() +  scale_fill_gradient2(low = "white", high = "black", mid = "gray", midpoint = 127.5) +  facet_wrap(~ label, nrow = 2) +  labs(title = "Average value of each pixel in 10 MNIST digits",       fill = "Average value") +  theme_void()

digit_differences <- crossing(compare1 = 0:9, compare2 = 0:9) %>%  filter(compare1 != compare2) %>%  mutate(negative = compare1, positive = compare2) %>%  gather(class, label, positive, negative) %>%  inner_join(pixel_summary, by = "label") %>%  select(-label) %>%  spread(class, mean_value)
ggplot(digit_differences, aes(x, y, fill = positive - negative)) +  geom_tile() +  scale_fill_gradient2(low = "blue", high = "red", mid = "white", midpoint = .5) +  facet_grid(compare2 ~ compare1) +  theme_void() +  labs(title = "Pixels that distinguish pairs of MNIST images",       subtitle = "Red means the pixel is darker for that row's digit, and blue means the pixel is darker for that column's digit.")

library(caret)

## Loading required package: lattice

## Warning: package 'lattice' was built under R version 3.6.2

## 
## Attaching package: 'caret'

## The following object is masked from 'package:purrr':
## 
##     lift

nonzero_var <- nearZeroVar(X, saveMetrics = FALSE)
image(matrix(1:784 %in% nonzero_var, 28, 28))

Data Processing

Dimensionality Reduction

Near Zero Variance

x <- nearZeroVar(X, saveMetrics = TRUE)
x

mnist_subset_reduced <- mnist_subset[ , nonzero_var]

PCA

Modeling

# Data Partitioning
set.seed(622)
trainIndex <- createDataPartition(mnist_subset_reduced$label, p = .8, list = FALSE, times = 1)
X_train <- X[trainIndex,]

## Warning: The `i` argument of ``[`()` can't be a matrix as of tibble 3.0.0.
## Convert to a vector.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.

y_train <- y[trainIndex]
X_test <- X[-trainIndex,]
y_test <- y[-trainIndex]

y_train <- as.factor(y_train)
y_test <- as.factor(y_test)

trControl <- trainControl(method  = "cv", number  = 3)

knn.fit <- train(X_train, y_train,
             method     = "knn",
             tuneGrid   = expand.grid(k = 1:5),
             trControl  = trControl)

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

## Warning: Setting row names on a tibble is deprecated.

knn.fit

## k-Nearest Neighbors 
## 
## 4001 samples
##  784 predictor
##   10 classes: '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' 
## 
## No pre-processing
## Resampling: Cross-Validated (3 fold) 
## Summary of sample sizes: 2667, 2668, 2667 
## Resampling results across tuning parameters:
## 
##   k  Accuracy   Kappa    
##   1  0.9305179  0.9227232
##   2  0.9162703  0.9068747
##   3  0.9240183  0.9154920
##   4  0.9212706  0.9124318
##   5  0.9200192  0.9110354
## 
## Accuracy was used to select the optimal model using the largest value.
## The final value used for the model was k = 1.

plot(knn.fit)

knnPredict <- predict(knn.fit, newdata = X_test) 
confusionMatrix(knnPredict, y_test)

## Confusion Matrix and Statistics
## 
##           Reference
## Prediction   0   1   2   3   4   5   6   7   8   9
##          0 103   0   0   0   0   0   0   0   1   2
##          1   0  99   2   1   2   1   1   1   2   1
##          2   0   3  92   1   0   0   1   0   0   0
##          3   0   0   1  85   0   2   0   0   3   0
##          4   0   0   0   0 108   0   0   1   0   5
##          5   0   0   0   3   0  80   0   0   3   1
##          6   2   0   0   1   1   2 102   0   1   1
##          7   0   0   4   2   0   0   0 102   0   3
##          8   0   0   0   0   0   0   0   0  76   0
##          9   0   0   0   0   1   0   0   4   0  92
## 
## Overall Statistics
##                                           
##                Accuracy : 0.9399          
##                  95% CI : (0.9234, 0.9539)
##     No Information Rate : 0.1121          
##     P-Value [Acc > NIR] : < 2.2e-16       
##                                           
##                   Kappa : 0.9332          
##                                           
##  Mcnemar's Test P-Value : NA              
## 
## Statistics by Class:
## 
##                      Class: 0 Class: 1 Class: 2 Class: 3 Class: 4 Class: 5
## Sensitivity            0.9810   0.9706  0.92929  0.91398   0.9643  0.94118
## Specificity            0.9966   0.9877  0.99444  0.99338   0.9932  0.99234
## Pos Pred Value         0.9717   0.9000  0.94845  0.93407   0.9474  0.91954
## Neg Pred Value         0.9978   0.9966  0.99224  0.99119   0.9955  0.99452
## Prevalence             0.1051   0.1021  0.09910  0.09309   0.1121  0.08509
## Detection Rate         0.1031   0.0991  0.09209  0.08509   0.1081  0.08008
## Detection Prevalence   0.1061   0.1101  0.09710  0.09109   0.1141  0.08709
## Balanced Accuracy      0.9888   0.9792  0.96187  0.95368   0.9788  0.96676
##                      Class: 6 Class: 7 Class: 8 Class: 9
## Sensitivity            0.9808   0.9444  0.88372  0.87619
## Specificity            0.9911   0.9899  1.00000  0.99441
## Pos Pred Value         0.9273   0.9189  1.00000  0.94845
## Neg Pred Value         0.9978   0.9932  0.98917  0.98559
## Prevalence             0.1041   0.1081  0.08609  0.10511
## Detection Rate         0.1021   0.1021  0.07608  0.09209
## Detection Prevalence   0.1101   0.1111  0.07608  0.09710
## Balanced Accuracy      0.9859   0.9672  0.94186  0.93530